home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / emacssrc.zip / EMACSSRC.TAR / emacs-19.17 / src / floatfns.c < prev    next >
C/C++ Source or Header  |  1993-10-07  |  23KB  |  900 lines
  1. /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
  2.    Copyright (C) 1988, 1993 Free Software Foundation, Inc.
  3.  
  4. This file is part of GNU Emacs.
  5.  
  6. GNU Emacs is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GNU Emacs is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with GNU Emacs; see the file COPYING.  If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20.  
  21. /* ANSI C requires only these float functions:
  22.    acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
  23.    frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
  24.  
  25.    Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
  26.    Define HAVE_CBRT if you have cbrt.
  27.    Define HAVE_RINT if you have rint.
  28.    If you don't define these, then the appropriate routines will be simulated.
  29.  
  30.    Define HAVE_MATHERR if on a system supporting the SysV matherr callback.
  31.    (This should happen automatically.)
  32.  
  33.    Define FLOAT_CHECK_ERRNO if the float library routines set errno.
  34.    This has no effect if HAVE_MATHERR is defined.
  35.  
  36.    Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
  37.    (What systems actually do this?  Please let us know.)
  38.  
  39.    Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
  40.    either setting errno, or signalling SIGFPE/SIGILL.  Otherwise, domain and
  41.    range checking will happen before calling the float routines.  This has
  42.    no effect if HAVE_MATHERR is defined (since matherr will be called when
  43.    a domain error occurs.)
  44.  */
  45.  
  46. #include <signal.h>
  47.  
  48. #include "config.h"
  49. #include "lisp.h"
  50. #include "syssignal.h"
  51.  
  52. #include "floatfns_p.h"
  53. static SIGTYPE float_error _P_((int signo));
  54.  
  55. Lisp_Object Qarith_error;
  56.  
  57. #ifdef LISP_FLOAT_TYPE
  58.  
  59. #include <math.h>
  60.  
  61. #ifndef hpux
  62. #ifndef WINDOWSNT
  63. /* These declarations are omitted on some systems, like Ultrix.  */
  64. extern double logb ();
  65. #endif
  66. #endif
  67.  
  68. #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW)
  69.     /* If those are defined, then this is probably a `matherr' machine. */
  70. # ifndef HAVE_MATHERR
  71. #  define HAVE_MATHERR
  72. # endif
  73. #endif
  74.  
  75. #ifdef WINDOWSNT
  76. #define NO_MATHERR
  77. #endif
  78.  
  79. #ifdef NO_MATHERR
  80. #undef HAVE_MATHERR
  81. #endif
  82.  
  83. #ifdef HAVE_MATHERR
  84. # ifdef FLOAT_CHECK_ERRNO
  85. #  undef FLOAT_CHECK_ERRNO
  86. # endif
  87. # ifdef FLOAT_CHECK_DOMAIN
  88. #  undef FLOAT_CHECK_DOMAIN
  89. # endif
  90. #endif
  91.  
  92. #ifndef NO_FLOAT_CHECK_ERRNO
  93. #define FLOAT_CHECK_ERRNO
  94. #endif
  95.  
  96. #ifdef FLOAT_CHECK_ERRNO
  97. # include <errno.h>
  98.  
  99. extern int errno;
  100. #endif
  101.  
  102. /* Avoid traps on VMS from sinh and cosh.
  103.    All the other functions set errno instead.  */
  104.  
  105. #ifdef VMS
  106. #undef cosh
  107. #undef sinh
  108. #define cosh(x) ((exp(x)+exp(-x))*0.5)
  109. #define sinh(x) ((exp(x)-exp(-x))*0.5)
  110. #endif /* VMS */
  111.  
  112. #ifndef HAVE_RINT
  113. #define rint(x) (floor((x)+0.5))
  114. #endif
  115.  
  116. /* Nonzero while executing in floating point.
  117.    This tells float_error what to do.  */
  118.  
  119. static int in_float;
  120.  
  121. /* If an argument is out of range for a mathematical function,
  122.    here is the actual argument value to use in the error message.  */
  123.  
  124. static Lisp_Object float_error_arg, float_error_arg2;
  125.  
  126. static char *float_error_fn_name;
  127.  
  128. /* Evaluate the floating point expression D, recording NUM
  129.    as the original argument for error messages.
  130.    D is normally an assignment expression.
  131.    Handle errors which may result in signals or may set errno.
  132.  
  133.    Note that float_error may be declared to return void, so you can't
  134.    just cast the zero after the colon to (SIGTYPE) to make the types
  135.    check properly.  */
  136.  
  137. #ifdef FLOAT_CHECK_ERRNO
  138. #define IN_FLOAT(d, name, num)                \
  139.   do {                            \
  140.     float_error_arg = num;                \
  141.     float_error_fn_name = name;                \
  142.     in_float = 1; errno = 0; (d); in_float = 0;        \
  143.     switch (errno) {                    \
  144.     case 0: break;                    \
  145.     case EDOM:     domain_error (float_error_fn_name, float_error_arg);    \
  146.     case ERANGE: range_error (float_error_fn_name, float_error_arg);    \
  147.     default:     arith_error (float_error_fn_name, float_error_arg);    \
  148.     }                            \
  149.   } while (0)
  150. #define IN_FLOAT2(d, name, num, num2)            \
  151.   do {                            \
  152.     float_error_arg = num;                \
  153.     float_error_arg2 = num2;                \
  154.     float_error_fn_name = name;                \
  155.     in_float = 1; errno = 0; (d); in_float = 0;        \
  156.     switch (errno) {                    \
  157.     case 0: break;                    \
  158.     case EDOM:     domain_error (float_error_fn_name, float_error_arg);    \
  159.     case ERANGE: range_error (float_error_fn_name, float_error_arg);    \
  160.     default:     arith_error (float_error_fn_name, float_error_arg);    \
  161.     }                            \
  162.   } while (0)
  163. #else
  164. #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
  165. #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0)
  166. #endif
  167.  
  168. #define arith_error(op,arg) \
  169.   Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
  170. #define range_error(op,arg) \
  171.   Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
  172. #define domain_error(op,arg) \
  173.   Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil)))
  174. #define domain_error2(op,a1,a2) \
  175.   Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((a1), Fcons ((a2), Qnil))))
  176.  
  177. /* Extract a Lisp number as a `double', or signal an error.  */
  178.  
  179. double
  180. extract_float (num)
  181.      Lisp_Object num;
  182. {
  183.   CHECK_NUMBER_OR_FLOAT (num, 0);
  184.  
  185.   if (XTYPE (num) == Lisp_Float)
  186.     return XFLOAT (num)->data;
  187.   return (double) XINT (num);
  188. }
  189.  
  190. /* Trig functions.  */
  191.  
  192. DEFUN ("acos", Facos, Sacos, 1, 1, 0,
  193.   "Return the inverse cosine of ARG.")
  194.   (arg)
  195.      register Lisp_Object arg;
  196. {
  197.   double d = extract_float (arg);
  198. #ifdef FLOAT_CHECK_DOMAIN
  199.   if (d > 1.0 || d < -1.0)
  200.     domain_error ("acos", arg);
  201. #endif
  202.   IN_FLOAT (d = acos (d), "acos", arg);
  203.   return make_float (d);
  204. }
  205.  
  206. DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
  207.   "Return the inverse sine of ARG.")
  208.   (arg)
  209.      register Lisp_Object arg;
  210. {
  211.   double d = extract_float (arg);
  212. #ifdef FLOAT_CHECK_DOMAIN
  213.   if (d > 1.0 || d < -1.0)
  214.     domain_error ("asin", arg);
  215. #endif
  216.   IN_FLOAT (d = asin (d), "asin", arg);
  217.   return make_float (d);
  218. }
  219.  
  220. DEFUN ("atan", Fatan, Satan, 1, 1, 0,
  221.   "Return the inverse tangent of ARG.")
  222.   (arg)
  223.      register Lisp_Object arg;
  224. {
  225.   double d = extract_float (arg);
  226.   IN_FLOAT (d = atan (d), "atan", arg);
  227.   return make_float (d);
  228. }
  229.  
  230. DEFUN ("cos", Fcos, Scos, 1, 1, 0,
  231.   "Return the cosine of ARG.")
  232.   (arg)
  233.      register Lisp_Object arg;
  234. {
  235.   double d = extract_float (arg);
  236.   IN_FLOAT (d = cos (d), "cos", arg);
  237.   return make_float (d);
  238. }
  239.  
  240. DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
  241.   "Return the sine of ARG.")
  242.   (arg)
  243.      register Lisp_Object arg;
  244. {
  245.   double d = extract_float (arg);
  246.   IN_FLOAT (d = sin (d), "sin", arg);
  247.   return make_float (d);
  248. }
  249.  
  250. DEFUN ("tan", Ftan, Stan, 1, 1, 0,
  251.   "Return the tangent of ARG.")
  252.   (arg)
  253.      register Lisp_Object arg;
  254. {
  255.   double d = extract_float (arg);
  256.   double c = cos (d);
  257. #ifdef FLOAT_CHECK_DOMAIN
  258.   if (c == 0.0)
  259.     domain_error ("tan", arg);
  260. #endif
  261.   IN_FLOAT (d = sin (d) / c, "tan", arg);
  262.   return make_float (d);
  263. }
  264.  
  265. #if 0 /* Leave these out unless we find there's a reason for them.  */
  266.  
  267. DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
  268.   "Return the bessel function j0 of ARG.")
  269.   (arg)
  270.      register Lisp_Object arg;
  271. {
  272.   double d = extract_float (arg);
  273.   IN_FLOAT (d = j0 (d), "bessel-j0", arg);
  274.   return make_float (d);
  275. }
  276.  
  277. DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
  278.   "Return the bessel function j1 of ARG.")
  279.   (arg)
  280.      register Lisp_Object arg;
  281. {
  282.   double d = extract_float (arg);
  283.   IN_FLOAT (d = j1 (d), "bessel-j1", arg);
  284.   return make_float (d);
  285. }
  286.  
  287. DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
  288.   "Return the order N bessel function output jn of ARG.\n\
  289. The first arg (the order) is truncated to an integer.")
  290.   (arg1, arg2)
  291.      register Lisp_Object arg1, arg2;
  292. {
  293.   int i1 = extract_float (arg1);
  294.   double f2 = extract_float (arg2);
  295.  
  296.   IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", arg1);
  297.   return make_float (f2);
  298. }
  299.  
  300. DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
  301.   "Return the bessel function y0 of ARG.")
  302.   (arg)
  303.      register Lisp_Object arg;
  304. {
  305.   double d = extract_float (arg);
  306.   IN_FLOAT (d = y0 (d), "bessel-y0", arg);
  307.   return make_float (d);
  308. }
  309.  
  310. DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
  311.   "Return the bessel function y1 of ARG.")
  312.   (arg)
  313.      register Lisp_Object arg;
  314. {
  315.   double d = extract_float (arg);
  316.   IN_FLOAT (d = y1 (d), "bessel-y0", arg);
  317.   return make_float (d);
  318. }
  319.  
  320. DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
  321.   "Return the order N bessel function output yn of ARG.\n\
  322. The first arg (the order) is truncated to an integer.")
  323.   (arg1, arg2)
  324.      register Lisp_Object arg1, arg2;
  325. {
  326.   int i1 = extract_float (arg1);
  327.   double f2 = extract_float (arg2);
  328.  
  329.   IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", arg1);
  330.   return make_float (f2);
  331. }
  332.  
  333. #endif
  334.  
  335. #if 0 /* Leave these out unless we see they are worth having.  */
  336.  
  337. DEFUN ("erf", Ferf, Serf, 1, 1, 0,
  338.   "Return the mathematical error function of ARG.")
  339.   (arg)
  340.      register Lisp_Object arg;
  341. {
  342.   double d = extract_float (arg);
  343.   IN_FLOAT (d = erf (d), "erf", arg);
  344.   return make_float (d);
  345. }
  346.  
  347. DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
  348.   "Return the complementary error function of ARG.")
  349.   (arg)
  350.      register Lisp_Object arg;
  351. {
  352.   double d = extract_float (arg);
  353.   IN_FLOAT (d = erfc (d), "erfc", arg);
  354.   return make_float (d);
  355. }
  356.  
  357. DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
  358.   "Return the log gamma of ARG.")
  359.   (arg)
  360.      register Lisp_Object arg;
  361. {
  362.   double d = extract_float (arg);
  363.   IN_FLOAT (d = lgamma (d), "log-gamma", arg);
  364.   return make_float (d);
  365. }
  366.  
  367. DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
  368.   "Return the cube root of ARG.")
  369.   (arg)
  370.      register Lisp_Object arg;
  371. {
  372.   double d = extract_float (arg);
  373. #ifdef HAVE_CBRT
  374.   IN_FLOAT (d = cbrt (d), "cube-root", arg);
  375. #else
  376.   if (d >= 0.0)
  377.     IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg);
  378.   else
  379.     IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg);
  380. #endif
  381.   return make_float (d);
  382. }
  383.  
  384. #endif
  385.  
  386. DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
  387.   "Return the exponential base e of ARG.")
  388.   (arg)
  389.      register Lisp_Object arg;
  390. {
  391.   double d = extract_float (arg);
  392. #ifdef FLOAT_CHECK_DOMAIN
  393.   if (d > 709.7827)   /* Assume IEEE doubles here */
  394.     range_error ("exp", arg);
  395.   else if (d < -709.0)
  396.     return make_float (0.0);
  397.   else
  398. #endif
  399.     IN_FLOAT (d = exp (d), "exp", arg);
  400.   return make_float (d);
  401. }
  402.  
  403. DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
  404.   "Return the exponential X ** Y.")
  405.   (arg1, arg2)
  406.      register Lisp_Object arg1, arg2;
  407. {
  408.   double f1, f2;
  409.  
  410.   CHECK_NUMBER_OR_FLOAT (arg1, 0);
  411.   CHECK_NUMBER_OR_FLOAT (arg2, 0);
  412.   if ((XTYPE (arg1) == Lisp_Int) && /* common lisp spec */
  413.       (XTYPE (arg2) == Lisp_Int)) /* don't promote, if both are ints */
  414.     {                /* this can be improved by pre-calculating */
  415.       int acc, x, y;        /* some binary powers of x then accumulating */
  416.       Lisp_Object val;
  417.  
  418.       x = XINT (arg1);
  419.       y = XINT (arg2);
  420.       acc = 1;
  421.       
  422.       if (y < 0)
  423.     {
  424.       if (x == 1)
  425.         acc = 1;
  426.       else if (x == -1)
  427.         acc = (y & 1) ? -1 : 1;
  428.       else
  429.         acc = 0;
  430.     }
  431.       else
  432.     {
  433.       for (; y > 0; y--)
  434.       while (y > 0)
  435.         {
  436.           if (y & 1)
  437.         acc *= x;
  438.           x *= x;
  439.           y = (unsigned)y >> 1;
  440.         }
  441.     }
  442.       XSET (val, Lisp_Int, acc);
  443.       return val;
  444.     }
  445.   f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1);
  446.   f2 = (XTYPE (arg2) == Lisp_Float) ? XFLOAT (arg2)->data : XINT (arg2);
  447.   /* Really should check for overflow, too */
  448.   if (f1 == 0.0 && f2 == 0.0)
  449.     f1 = 1.0;
  450. #ifdef FLOAT_CHECK_DOMAIN
  451.   else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
  452.     domain_error2 ("expt", arg1, arg2);
  453. #endif
  454.   IN_FLOAT (f1 = pow (f1, f2), "expt", arg1);
  455.   return make_float (f1);
  456. }
  457.  
  458. DEFUN ("log", Flog, Slog, 1, 2, 0,
  459.   "Return the natural logarithm of ARG.\n\
  460. If second optional argument BASE is given, return log ARG using that base.")
  461.   (arg, base)
  462.      register Lisp_Object arg, base;
  463. {
  464.   double d = extract_float (arg);
  465.  
  466. #ifdef FLOAT_CHECK_DOMAIN
  467.   if (d <= 0.0)
  468.     domain_error2 ("log", arg, base);
  469. #endif
  470.   if (NILP (base))
  471.     IN_FLOAT (d = log (d), "log", arg);
  472.   else
  473.     {
  474.       double b = extract_float (base);
  475.  
  476. #ifdef FLOAT_CHECK_DOMAIN
  477.       if (b <= 0.0 || b == 1.0)
  478.     domain_error2 ("log", arg, base);
  479. #endif
  480.       if (b == 10.0)
  481.     IN_FLOAT2 (d = log10 (d), "log", arg, base);
  482.       else
  483.     IN_FLOAT2 (d = log (d) / log (b), "log", arg, base);
  484.     }
  485.   return make_float (d);
  486. }
  487.  
  488. DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
  489.   "Return the logarithm base 10 of ARG.")
  490.   (arg)
  491.      register Lisp_Object arg;
  492. {
  493.   double d = extract_float (arg);
  494. #ifdef FLOAT_CHECK_DOMAIN
  495.   if (d <= 0.0)
  496.     domain_error ("log10", arg);
  497. #endif
  498.   IN_FLOAT (d = log10 (d), "log10", arg);
  499.   return make_float (d);
  500. }
  501.  
  502. DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
  503.   "Return the square root of ARG.")
  504.   (arg)
  505.      register Lisp_Object arg;
  506. {
  507.   double d = extract_float (arg);
  508. #ifdef FLOAT_CHECK_DOMAIN
  509.   if (d < 0.0)
  510.     domain_error ("sqrt", arg);
  511. #endif
  512.   IN_FLOAT (d = sqrt (d), "sqrt", arg);
  513.   return make_float (d);
  514. }
  515.  
  516. #if 0 /* Not clearly worth adding.  */
  517.  
  518. DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
  519.   "Return the inverse hyperbolic cosine of ARG.")
  520.   (arg)
  521.      register Lisp_Object arg;
  522. {
  523.   double d = extract_float (arg);
  524. #ifdef FLOAT_CHECK_DOMAIN
  525.   if (d < 1.0)
  526.     domain_error ("acosh", arg);
  527. #endif
  528. #ifdef HAVE_INVERSE_HYPERBOLIC
  529.   IN_FLOAT (d = acosh (d), "acosh", arg);
  530. #else
  531.   IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
  532. #endif
  533.   return make_float (d);
  534. }
  535.  
  536. DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
  537.   "Return the inverse hyperbolic sine of ARG.")
  538.   (arg)
  539.      register Lisp_Object arg;
  540. {
  541.   double d = extract_float (arg);
  542. #ifdef HAVE_INVERSE_HYPERBOLIC
  543.   IN_FLOAT (d = asinh (d), "asinh", arg);
  544. #else
  545.   IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
  546. #endif
  547.   return make_float (d);
  548. }
  549.  
  550. DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
  551.   "Return the inverse hyperbolic tangent of ARG.")
  552.   (arg)
  553.      register Lisp_Object arg;
  554. {
  555.   double d = extract_float (arg);
  556. #ifdef FLOAT_CHECK_DOMAIN
  557.   if (d >= 1.0 || d <= -1.0)
  558.     domain_error ("atanh", arg);
  559. #endif
  560. #ifdef HAVE_INVERSE_HYPERBOLIC
  561.   IN_FLOAT (d = atanh (d), "atanh", arg);
  562. #else
  563.   IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
  564. #endif
  565.   return make_float (d);
  566. }
  567.  
  568. DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
  569.   "Return the hyperbolic cosine of ARG.")
  570.   (arg)
  571.      register Lisp_Object arg;
  572. {
  573.   double d = extract_float (arg);
  574. #ifdef FLOAT_CHECK_DOMAIN
  575.   if (d > 710.0 || d < -710.0)
  576.     range_error ("cosh", arg);
  577. #endif
  578.   IN_FLOAT (d = cosh (d), "cosh", arg);
  579.   return make_float (d);
  580. }
  581.  
  582. DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
  583.   "Return the hyperbolic sine of ARG.")
  584.   (arg)
  585.      register Lisp_Object arg;
  586. {
  587.   double d = extract_float (arg);
  588. #ifdef FLOAT_CHECK_DOMAIN
  589.   if (d > 710.0 || d < -710.0)
  590.     range_error ("sinh", arg);
  591. #endif
  592.   IN_FLOAT (d = sinh (d), "sinh", arg);
  593.   return make_float (d);
  594. }
  595.  
  596. DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
  597.   "Return the hyperbolic tangent of ARG.")
  598.   (arg)
  599.      register Lisp_Object arg;
  600. {
  601.   double d = extract_float (arg);
  602.   IN_FLOAT (d = tanh (d), "tanh", arg);
  603.   return make_float (d);
  604. }
  605. #endif
  606.  
  607. DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
  608.   "Return the absolute value of ARG.")
  609.   (arg)
  610.      register Lisp_Object arg;
  611. {
  612.   CHECK_NUMBER_OR_FLOAT (arg, 0);
  613.  
  614.   if (XTYPE (arg) == Lisp_Float)
  615.     IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg);
  616.   else if (XINT (arg) < 0)
  617.     XSETINT (arg, - XFASTINT (arg));
  618.  
  619.   return arg;
  620. }
  621.  
  622. DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
  623.   "Return the floating point number equal to ARG.")
  624.   (arg)
  625.      register Lisp_Object arg;
  626. {
  627.   CHECK_NUMBER_OR_FLOAT (arg, 0);
  628.  
  629.   if (XTYPE (arg) == Lisp_Int)
  630.     return make_float ((double) XINT (arg));
  631.   else                /* give 'em the same float back */
  632.     return arg;
  633. }
  634.  
  635. DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
  636.   "Returns the integer not greater than the base 2 log of the magnitude of ARG.\n\
  637. This is the same as the exponent of a float.")
  638.      (arg)
  639.      Lisp_Object arg;
  640. {
  641.   Lisp_Object val;
  642. #ifndef WINDOWSNT
  643.   int value;
  644. #endif
  645.   double f = extract_float (arg);
  646.  
  647. #ifdef USG
  648.   {
  649.     int exp;  
  650.  
  651.     IN_FLOAT (frexp (f, &exp), "logb", arg);
  652.     XSET (val, Lisp_Int, exp-1);
  653.   }
  654. #elif WINDOWSNT
  655.   {
  656.     int exp;  
  657.  
  658.     IN_FLOAT (frexp (f, &exp), "logb", arg);
  659.     XSET (val, Lisp_Int, exp-1);
  660.   }
  661. #else
  662.   IN_FLOAT (value = logb (f), "logb", arg);
  663.   XSET (val, Lisp_Int, value);
  664. #endif
  665.  
  666.   return val;
  667. }
  668.  
  669. /* the rounding functions  */
  670.  
  671. DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
  672.   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
  673.   (arg)
  674.      register Lisp_Object arg;
  675. {
  676.   CHECK_NUMBER_OR_FLOAT (arg, 0);
  677.  
  678.   if (XTYPE (arg) == Lisp_Float)
  679.     IN_FLOAT (XSET (arg, Lisp_Int, ceil (XFLOAT (arg)->data)), "ceiling", arg);
  680.  
  681.   return arg;
  682. }
  683.  
  684. DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0,
  685.   "Return the largest integer no greater than ARG.  (Round towards -inf.)")
  686.   (arg)
  687.      register Lisp_Object arg;
  688. {
  689.   CHECK_NUMBER_OR_FLOAT (arg, 0);
  690.  
  691.   if (XTYPE (arg) == Lisp_Float)
  692.     IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg);
  693.  
  694.   return arg;
  695. }
  696.  
  697. DEFUN ("round", Fround, Sround, 1, 1, 0,
  698.   "Return the nearest integer to ARG.")
  699.   (arg)
  700.      register Lisp_Object arg;
  701. {
  702.   CHECK_NUMBER_OR_FLOAT (arg, 0);
  703.  
  704.   if (XTYPE (arg) == Lisp_Float)
  705.     /* Screw the prevailing rounding mode.  */
  706.     IN_FLOAT (XSET (arg, Lisp_Int, rint (XFLOAT (arg)->data)), "round", arg);
  707.  
  708.   return arg;
  709. }
  710.  
  711. DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
  712.        "Truncate a floating point number to an int.\n\
  713. Rounds the value toward zero.")
  714.   (arg)
  715.      register Lisp_Object arg;
  716. {
  717.   CHECK_NUMBER_OR_FLOAT (arg, 0);
  718.  
  719.   if (XTYPE (arg) == Lisp_Float)
  720.     XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data);
  721.  
  722.   return arg;
  723. }
  724.  
  725. #if 0
  726. /* It's not clear these are worth adding.  */
  727.  
  728. DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
  729.   "Return the smallest integer no less than ARG, as a float.\n\
  730. \(Round toward +inf.\)")
  731.   (arg)
  732.      register Lisp_Object arg;
  733. {
  734.   double d = extract_float (arg);
  735.   IN_FLOAT (d = ceil (d), "fceiling", arg);
  736.   return make_float (d);
  737. }
  738.  
  739. DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
  740.   "Return the largest integer no greater than ARG, as a float.\n\
  741. \(Round towards -inf.\)")
  742.   (arg)
  743.      register Lisp_Object arg;
  744. {
  745.   double d = extract_float (arg);
  746.   IN_FLOAT (d = floor (d), "ffloor", arg);
  747.   return make_float (d);
  748. }
  749.  
  750. DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
  751.   "Return the nearest integer to ARG, as a float.")
  752.   (arg)
  753.      register Lisp_Object arg;
  754. {
  755.   double d = extract_float (arg);
  756.   IN_FLOAT (d = rint (XFLOAT (arg)->data), "fround", arg);
  757.   return make_float (d);
  758. }
  759.  
  760. DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
  761.        "Truncate a floating point number to an integral float value.\n\
  762. Rounds the value toward zero.")
  763.   (arg)
  764.      register Lisp_Object arg;
  765. {
  766.   double d = extract_float (arg);
  767.   if (d >= 0.0)
  768.     IN_FLOAT (d = floor (d), "ftruncate", arg);
  769.   else
  770.     IN_FLOAT (d = ceil (d), arg);
  771.   return make_float (d);
  772. }
  773. #endif
  774.  
  775. #ifdef FLOAT_CATCH_SIGILL
  776. static SIGTYPE
  777. float_error (signo)
  778.      int signo;
  779. {
  780.   if (! in_float)
  781.     fatal_error_signal (signo);
  782.  
  783. #ifdef BSD
  784. #ifdef BSD4_1
  785.   sigrelse (SIGILL);
  786. #else /* not BSD4_1 */
  787.   sigsetmask (SIGEMPTYMASK);
  788. #endif /* not BSD4_1 */
  789. #else
  790.   /* Must reestablish handler each time it is called.  */
  791.   signal (SIGILL, float_error);
  792. #endif /* BSD */
  793.  
  794.   in_float = 0;
  795.  
  796.   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
  797. }
  798.  
  799. /* Another idea was to replace the library function `infnan'
  800.    where SIGILL is signaled.  */
  801.  
  802. #endif /* FLOAT_CATCH_SIGILL */
  803.  
  804. #ifdef HAVE_MATHERR
  805. int 
  806. matherr (x)
  807.      struct exception *x;
  808. {
  809.   Lisp_Object args;
  810.   if (! in_float)
  811.     /* Not called from emacs-lisp float routines; do the default thing. */
  812.     return 0;
  813.   if (!strcmp (x->name, "pow"))
  814.     x->name = "expt";
  815.  
  816.   args
  817.     = Fcons (build_string (x->name),
  818.          Fcons (make_float (x->arg1),
  819.             ((!strcmp (x->name, "log") || !strcmp (x->name, "pow"))
  820.              ? Fcons (make_float (x->arg2), Qnil)
  821.              : Qnil)));
  822.   switch (x->type)
  823.     {
  824.     case DOMAIN:    Fsignal (Qdomain_error, args);        break;
  825.     case SING:        Fsignal (Qsingularity_error, args);    break;
  826.     case OVERFLOW:    Fsignal (Qoverflow_error, args);    break;
  827.     case UNDERFLOW:    Fsignal (Qunderflow_error, args);    break;
  828.     default:        Fsignal (Qarith_error, args);        break;
  829.     }
  830.   return (1);    /* don't set errno or print a message */
  831. }
  832. #endif /* HAVE_MATHERR */
  833.  
  834. _VOID_
  835. init_floatfns ()
  836. {
  837. #ifdef FLOAT_CATCH_SIGILL
  838.   signal (SIGILL, float_error);
  839. #endif 
  840.   in_float = 0;
  841. }
  842.  
  843. _VOID_
  844. syms_of_floatfns ()
  845. {
  846.   defsubr (&Sacos);
  847.   defsubr (&Sasin);
  848.   defsubr (&Satan);
  849.   defsubr (&Scos);
  850.   defsubr (&Ssin);
  851.   defsubr (&Stan);
  852. #if 0
  853.   defsubr (&Sacosh);
  854.   defsubr (&Sasinh);
  855.   defsubr (&Satanh);
  856.   defsubr (&Scosh);
  857.   defsubr (&Ssinh);
  858.   defsubr (&Stanh);
  859.   defsubr (&Sbessel_y0);
  860.   defsubr (&Sbessel_y1);
  861.   defsubr (&Sbessel_yn);
  862.   defsubr (&Sbessel_j0);
  863.   defsubr (&Sbessel_j1);
  864.   defsubr (&Sbessel_jn);
  865.   defsubr (&Serf);
  866.   defsubr (&Serfc);
  867.   defsubr (&Slog_gamma);
  868.   defsubr (&Scube_root);
  869.   defsubr (&Sfceiling);
  870.   defsubr (&Sffloor);
  871.   defsubr (&Sfround);
  872.   defsubr (&Sftruncate);
  873. #endif
  874.   defsubr (&Sexp);
  875.   defsubr (&Sexpt);
  876.   defsubr (&Slog);
  877.   defsubr (&Slog10);
  878.   defsubr (&Ssqrt);
  879.  
  880.   defsubr (&Sabs);
  881.   defsubr (&Sfloat);
  882.   defsubr (&Slogb);
  883.   defsubr (&Sceiling);
  884.   defsubr (&Sfloor);
  885.   defsubr (&Sround);
  886.   defsubr (&Struncate);
  887. }
  888.  
  889. #else /* not LISP_FLOAT_TYPE */
  890.  
  891. _VOID_
  892. init_floatfns ()
  893. {}
  894.  
  895. _VOID_
  896. syms_of_floatfns ()
  897. {}
  898.  
  899. #endif /* not LISP_FLOAT_TYPE */
  900.